home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / More classes / Multitasking < prev    next >
Text File  |  1998-05-02  |  13KB  |  445 lines
  1. \ Multitasking.  April 88.
  2.  
  3. \ Feb 90 - M stack refs removed for Mops 1.2.
  4.  
  5. (*
  6.  
  7. One of the beauties of a Forth-based system is that it is easy to implement
  8. multitasking.  This allows us to do interesting things like continue processing
  9. while a window is being dragged etc.  Most Mac applications can't manage this. 
  10. It makes our applications look unbelievably sophisticated, and yet this code is
  11. only about 2500 bytes.  This is possible because the Forth approach to
  12. multitasking, as usual, simplifies things considerably compared with other
  13. systems.
  14.  
  15. The main simplifying factor is that the scheme is cooperative.  Tasks cannot be
  16. interrupted at any arbitrary point, but must execute PAUSE to allow other tasks
  17. to have a turn.  This allows the overhead for switching tasks to be just about
  18. 20 machine instructions.
  19.  
  20. This code is based on that in the Laxen/Perry F83, including the extra features
  21. added by yours truly in the PDP-11 implementation, notably the mechanism to
  22. keep track of the status of a task.  We make some necessary Mac and Mops
  23. adaptations here - in particular, a task becomes a Mops object, and we set the
  24. various user hook locations (e.g. DragHook) to point to a routine to run the
  25. task round-robin.  Another addition is that each task has a queue of tasks
  26. waiting on it.  This avoids a waiting task having to waste time testing the
  27. other task each time round.  A waiting task can now be put to sleep, and the
  28. time penalty for each waiting task is reduced to one machine JMP instruction
  29. each time round the task loop. If it was worth it, we could even remove the
  30. task from the loop altogether, but it probably isn't worth it.
  31.  
  32. Another necessary Mac adjustment is that we must distinguish between a
  33. foreground task and various background tasks.  Any time WaitNextEvent is
  34. called, all kinds of things can happen which can use several K of stack space. 
  35. Therefore we assume in allocating this space that WNE will only be called from
  36. the foreground task, and we don't need to allocate as much stack space for
  37. background tasks.  Also, the hook procedures must be able to ensure that WNE
  38. will not be called during their execution (very illegal).  If we call WNE only
  39. from the foreground task, there's no problem.  The hook procedures then always
  40. execute as part of the foreground task (they're called by the system at WNE
  41. time), and even if they give background tasks some time before they return,
  42. these background tasks won't be calling WNE.
  43.  
  44. Another thing to watch is that a background task shouldn't do any drawing to
  45. the screen  Not only doesn't it know which GrafPort is switched in, I have also
  46. found QuickDraw doing some strange things in the "unused" area of the stack
  47. between BufPtr and the current A7 stack pointer!!  We therefore now put the
  48. foreground stack LOWEST in memory - this necessitates moving the stack when a
  49. background task is allocated, but at least it avoids any problems with
  50. QuickDraw, since, assuming QuickDraw calls only result from foreground tasks,
  51. the stack pointer at system call time will really represent the lowest address
  52. we need for any of our stacks.
  53.  
  54. Our general philosophy, then, is that the foreground task will look after the
  55. user interface, do all drawing to the screen, and manage the event loop.  It
  56. will delegate any lengthy computation to background tasks, which therefore just
  57. function as computing engines for the foreground.
  58.  
  59. Things would have been a lot easier if we could have allocated a heap block for
  60. each background task's stack.  But then we would get caught by the VBL "stack
  61. sniffer" routine, which would find SP pointing below ApplLimit, think that the
  62. stack had encroached into the heap zone, and politely bow out with system error
  63. 28 (stack collides with heap).
  64.  
  65. \            ================================
  66.  
  67. \ Here we define values for the space to be allocated for the Mops stacks for new tasks.  These values may be changed as required.  It's better to err on the big side.  Remember that any Toolbox calls can use a lot of data stack space.
  68.  
  69.  2000    value    R_SPACE
  70.  3000    value    S_SPACE
  71.  
  72. 16000    value    FGD_S_SPACE
  73.  
  74.     0    value    REAL_RP0
  75.     0    value    NEW_SP
  76.  
  77.  
  78. \ Possible task statuses:
  79.  
  80. type{  AWAKE  ASLEEP  WAITING  STOPPED  TERMINATED  AVAILABLE  CRASHED  }
  81.  
  82.  
  83. \ Constants for the 68000 opcodes we need:
  84.  
  85. $ 4EF9 constant    QJMP        \ JMP (absolute long)
  86. $ 6104 constant    QBSR        \ BSR  +4
  87.  
  88. objPtr    THIS_TASK        \ Points to the currently running task.
  89.  
  90. objPtr    TSK1            \ Used for tracking task queues.
  91. objPtr    TSK2            \  Will be set to class Task.
  92.  
  93.     0    value    STP        \ Stack allocation pointer.
  94.  
  95.  
  96. \            ====================
  97.  
  98. :code  SUSPEND
  99.     movem.l    d2-d7/a2/a5/a7,-(a6)        ; Save all relevant regs
  100.     movem.l    dic[ExtraLocals],d0-d7/a0/a1    ; Save ExtraLocals area
  101.     movem.l    d0-d7/a0/a1,-(a6)
  102.     movem.l    40(dic[ExtraLocals]),d0-d7/a0/a1
  103.     movem.l    d0-d7/a0/a1,-(a6)
  104.     move    dic[this_task],a1
  105.     move    a6,12(a1)    ; Save data stk ptr in task object
  106.     move    2(a1),a0
  107.     jmp    (a0)    ; JMP to LINK to restart next task.
  108. ;code
  109.  
  110. :code  RESTART
  111.     move    (a7)+,a1
  112.     subq    #2,a1    ; A1 -> task object addr
  113.     move    18(a1),dic[SP0]    ; Set SP0
  114.     move    22(a1),dic[RP0]    ; Set RP0
  115.     move    12(a1),a6    ; Set SP
  116.     lea    rel[this_task],a0    ; We may be based on A5, not set up yet
  117.     move.l    a1,(a0)
  118.     movem.l    (a6)+,d0-d7/a0/a1        ; Restore ExtraLocals area
  119.     movem.l    d0-d7/a0/a1,40(dic[ExtraLocals]
  120.     movem.l    (a6)+,d0-d7/a0/a1
  121.     movem.l    d0-d7/a0/a1,dic[ExtraLocals]
  122.     movem.l    (a6)+,d2-d7/a2/a5/a7        ; Restore saved regs
  123.     rts
  124. ;code
  125.  
  126.  
  127. : NoRoom    159 die  ;
  128.  
  129. :code  MOVE_TASKS    \ ( dist -- )
  130.     loc
  131.     pop.l    d1    ; D1 = distance to move
  132.     move.l    a6,d0
  133.     sub.l    d1,d0    ; D0 = tentative destination
  134.     cmp.l    glob[ApplLimit],d0
  135.     blo.s    dic[noRoom]
  136.     sub.l    d1,dic[SP0]
  137.     sub.l    d1,dic[RP0]
  138.     move.l    d0,a1    ; A1 -> destination
  139.     move.l    dic[real_RP0],d0
  140.     sub.l    a6,d0    ; D0 = #bytes to move
  141.     move.l    a7,a0
  142.     sub.l    d1,a0
  143.     move.l    a0,dic[new_SP]
  144.     move.l    a6,a0    ; A0 -> source
  145.     move.l    a1,a7    ; Set A7 low in case of an interrupt during
  146.     move.l    a1,a6    ;  the loop
  147.     addq.l    #8,d0
  148. loop    move.l    (a0)+,(a1)+
  149.     subq.l    #4,d0
  150. lptest    bgt.s    loop
  151.     move.l    dic[new_SP],a7
  152. ;code
  153.  
  154.  
  155. forward    CRASH
  156. forward    NOWHERE
  157.  
  158.  
  159. :class    TASK    super{ object }
  160. record
  161. {    int    ENTRY
  162.     var    LINK
  163.     int    JMP_CODE
  164.     var    ^RESTART
  165.     var    ^SP
  166.     int    STATUS
  167.     var    tSP0
  168.     var    tRP0
  169.     var    QUEUE
  170.     var    QLINK
  171.     int    QSTATUS
  172. }
  173.  
  174. ' this_task    set_to_class  task
  175. ' tsk1        set_to_class  task
  176. ' tsk2        set_to_class  task
  177.  
  178.  
  179. :m (SLEEP):        QJMP  put: entry  ;m
  180. :m SLEEP:        asleep  put: status   (sleep): self  ;m
  181. :m WAKE:        QBSR  put: entry    awake  put: status  ;m
  182.  
  183. :m NEXT:        get: link  ;m
  184. :m SETNEXT:    put: link  ;m
  185.  
  186. :m NEXTQ:        get: Qlink  ;m
  187. :m SETNEXTQ:    put: Qlink  ;m
  188.  
  189. :m ?RESUME:    \ ( status# -- b )
  190.     get: Qstatus  >=  dup
  191.     IF  wake: self  THEN  ;m
  192.  
  193. :m RELEASEQ:
  194.     nilP -> tsk1   get: queue  -> tsk2
  195.     BEGIN
  196.         tsk2  nilP =  ?EXIT
  197.         get: status  ?resume: tsk2
  198.         IF  ( resumed - remove from queue )
  199.             nextQ: tsk2
  200.             tsk1  nilP =
  201.             IF  put: queue  ELSE  setnextQ: tsk1  THEN
  202.         THEN
  203.         tsk2 -> tsk1  nextQ: tsk2  -> tsk2
  204.     AGAIN  ;m
  205.  
  206.  
  207. :m (WAIT):    \ ( status# -- )  Used by Wait: - see below.
  208.     put: Qstatus  waiting  put: status  releaseQ: self
  209.     (sleep): self  ;m
  210.  
  211. :m WAIT:    \ ( status# -- ).
  212.     \ If the given status# is greater than the status of SELF, the currently
  213.     \ running task is queued and put to sleep.  It will be woken when the
  214.     \ status of SELF goes to the given status# or higher.  If the given status#
  215.     \ is less than or equal to the status of SELF, we don't queue this_task,
  216.     \ since the condition it wishes to wait for has already occurred.  However
  217.     \ we make it do a "phantom" wait so that its own queue will be released.  
  218.     \ Logically it has waited, so any tasks waiting for it to wait, must be
  219.     \ released.
  220.  
  221.     dup  (wait): this_task
  222.     get: status  <=
  223.     IF    wake: this_task
  224.     ELSE
  225.         get: queue  setnextQ: this_task
  226.         this_task  put: queue  
  227.         next_task
  228.     THEN  ;m
  229.  
  230. :m STATUS:    get: status  ;m
  231. :m SETSTATUS:    put: status  releaseQ: self  ;m
  232.  
  233. :m ASSIGN:  { PC \ sptr -- }
  234.     get: status  available  <>  abort" Task not available"
  235.         \ Now we set up a "saved reg" image so that it looks like
  236.         \ we've been suspended with PC as the return address.
  237.     get: tSP0  -> sptr
  238.     -4 ++> sptr
  239.     get: tRP0 4-  ['] nowhere    over !    \ Initial higher rtn addr
  240.          4-  PC        over !    \ Initial rtn addr
  241.                     sptr !    \ Initial A7 = rtn stk ptr
  242.       -4 ++> sptr    modbase        sptr !    \ Initial A5 = modbase
  243.       -4 ++> sptr    -1        sptr !    \ Initial A2 - here's hoping!
  244.     -104 ++> sptr                \ Room for D2-D7 and ExtraLocals
  245.     sptr  put: ^SP
  246.     sleep: self  ;m
  247.  
  248. :m RESET:
  249.     available  put: status   ;m
  250.  
  251. :m DISPLACE:  { dist -- }
  252.     dist -: ^SP
  253.     dist -: tSP0
  254.     dist -: tRP0  ;m
  255.     
  256. \ NEW: sets up various items in this task object, which are dependent on
  257. \ the current Mops base and stack location.  These can't be determined
  258. \ until run time, especially under MultiFinder.  Each task must be
  259. \ initialized at run time with NEW:, starting with FOREGROUND.  Note:
  260. \ FOREGROUND MUST BE FIRST.
  261.  
  262. :m NEW:
  263.     ['] restart  put: ^restart
  264.     this_task  nilP =
  265.     IF  \ This is the first one, i.e FOREGROUND
  266.         ^base  setnext: self
  267.         ^base  -> this_task        \ Point LINK to ourselves
  268.         sp@ -> stp            \ Set initial stp ready for backgd tasks
  269.         SP0  put: tSP0
  270.         RP0  put: tRP0
  271.         RP0 -> real_RP0
  272.         wake: self
  273.     ELSE
  274.         R_space S_space +  dup  move_tasks
  275.         this_task -> tsk1        \ Ought to be Foreground
  276.         BEGIN
  277.             dup  displace: tsk1
  278.             next: tsk1  -> tsk1
  279.             tsk1 this_task =
  280.         UNTIL  drop
  281.         next: this_task  setnext: self
  282.         ^base  setnext: this_task    \ Link ourselves into chain
  283.         real_RP0  dup    put: tRP0
  284.         R_space -    put: tSP0
  285.         available  put: status
  286.         ['] crash  assign: self      \ In case we wake: prematurely
  287.         available  put: status      \ not really asleep
  288.     THEN  ;m
  289.  
  290. :m .Q:
  291.     get: queue  -> tsk1
  292.     tsk1 nilP =  IF  ." empty"  EXIT  THEN
  293.     BEGIN
  294.         tsk1 nilP =  ?EXIT
  295.         .id: tsk1  space  tsk1 .h space
  296.         nextq: tsk1  -> tsk1
  297.     AGAIN  ;m
  298.  
  299. :m .STATUS:
  300.     1000  get: status  getIndStr  type  ;m
  301.  
  302. :m DUMP:
  303.     .class: self  3 spaces  .id: self
  304.     ."   status: "  .status: self
  305.     ."   queue: "   .q: self  cr  ;m
  306.  
  307.  
  308. :m CLASSINIT:
  309.     qJMP  put: JMP_code
  310.     nilP  put: queue  ;m
  311.  
  312. ;class
  313.  
  314. \ Now create task FOREGROUND as the currently running task:
  315.  
  316. task  FOREGROUND
  317.  
  318. \ Now we set up the user hooks so that if we are multitasking, other tasks
  319. \ can keep running while windows are being dragged or menus being selected.
  320.  
  321. $ A30    constant    MENUHOOK
  322. $ 9F6    constant    DRAGHOOK
  323.  
  324. :proc RUN_THEM   suspend   ;proc
  325.  
  326. :proc (SFD)
  327.     drop        \ Dlg ptr not needed
  328.     i->l >r        \ Item #
  329.     word0 drop    \ Left for return result - don't need it now
  330.     r 100 =
  331.     IF  ( null event )  next_task  THEN
  332.     r> makeint  ;proc
  333.  
  334.  
  335. \ MULTI and SINGLE turn multitasking on and off respectively.  MULTI, among
  336. \ other things, redirects PAUSE to just switch tasks.  Without multitasking,
  337. \ we make PAUSE call next: fEvent, but with multitasking, this becomes
  338. \ the foreground task's sole responsibility, and we mustn't do it anywhere
  339. \ else.
  340.  
  341. : MULTI
  342.     ['] suspend  -> next_task  ['] suspend  -> pause
  343.     ['] run_them  dup  MenuHook !  DragHook !
  344.     ['] (sfd)  -> SFdlgHook
  345.     0 -> sleepticks  ;
  346.  
  347. : SINGLE
  348.     ['] null  -> next_task  ['] (pause)  -> pause
  349.     0 MenuHook !  0 DragHook !
  350.     0 -> SFdlgHook
  351.     20 -> sleepticks  ;
  352.  
  353.  
  354. \ Task manipulation
  355.  
  356. : (STOP)        (sleep): this_task  suspend   ;
  357. : STOP        stopped  setStatus: this_task
  358.         releaseQ: this_task  (stop)   ;
  359.  
  360. :f CRASH
  361.     BEGIN
  362. \        3 beep  ." !! no code assigned to task " .id: this_task
  363.         crashed  setStatus: this_task  (stop)
  364.     AGAIN  ;f
  365.  
  366. :f NOWHERE    \ A running task at its top level has really been called
  367.             \ from nowhere.  So we define NOWHERE so that if it returns,
  368.             \ it will actually go to NOWHERE, which is somewhere, not just
  369.             \ anywhere.  (I hope that's clear.)
  370.             \ We define this as normal termination of a task.  Any attempt
  371.             \  to wake: a terminated task causes CRASH to be executed.
  372.  
  373.     terminated  setStatus: this_task
  374.     releaseQ: this_task  (stop)  crash  ;f
  375.  
  376.  
  377. : .TASKS
  378.     foreground
  379.     BEGIN
  380.         dup dump: **  next: **
  381.         dup foreground =
  382.     UNTIL  drop   ;
  383.  
  384. : CLTSK        \ This is called on an abort.  We execute the normal
  385.         \ abort action, then stop the currently
  386.         \ running task and set its status to crashed, unless
  387.         \ it's Foreground (which we'd better not stop)!
  388.  
  389.     cl3                \ Previous abort action
  390.     this_task nilP =  ?EXIT        \ Out if nothing initialized
  391.     this_task foreground =  ?EXIT    \ Or if this is foreground
  392.     crashed  setStatus: this_task  ['] crash >r
  393.     releaseQ: this_task  (stop)  ;
  394.  
  395. ' clTsk -> abortVec
  396.  
  397. \ endload
  398.  
  399. \ TESTING:
  400.  
  401. task  T1   task  T2
  402.  
  403.  0 value    CNT
  404. 10 value    CNT1
  405.  0 value    CNT2
  406. 10 value    CNT3
  407.  
  408. file F
  409.  
  410. : HAHA
  411.     1 2 3
  412.     BEGIN
  413.         next_task  cnt
  414.         NIF    500 -> cnt  -1 ++> cnt1
  415.             ." haha " cr
  416. \            waiting wait: t2
  417.         ELSE    -1 ++> cnt
  418.         THEN
  419.     cnt1
  420.     NUNTIL  ;
  421.  
  422. : HOHO
  423.     -4 -5 -6
  424.     BEGIN
  425.         next_task  cnt2
  426.         NIF
  427.             800 -> cnt2  -1 ++> cnt3
  428.             ." hoho " cr
  429. \            waiting wait: t1
  430.         ELSE  -1 ++> cnt2
  431.         THEN
  432.     cnt3
  433.     NUNTIL  ;
  434.  
  435. : GO
  436.     new: foreground  new: t1  new: t2
  437. \    ['] haha  assign: t1
  438. \    ['] hoho  assign: t2
  439.     wake: t1  ( wake: t2 )
  440.     multi
  441. \    'type TEXT 1  stdGet: f  drop
  442. ;
  443.  
  444. : QQ    wake: t2  ;
  445.